home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / ice-9 / expect.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  6.7 KB  |  197 lines
  1. ;;;;     Copyright (C) 1996, 1998, 1999, 2001 Free Software Foundation, Inc.
  2. ;;;;
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;;
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;;
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; As a special exception, the Free Software Foundation gives permission
  19. ;;;; for additional uses of the text contained in its release of GUILE.
  20. ;;;;
  21. ;;;; The exception is that, if you link the GUILE library with other files
  22. ;;;; to produce an executable, this does not by itself cause the
  23. ;;;; resulting executable to be covered by the GNU General Public License.
  24. ;;;; Your use of that executable is in no way restricted on account of
  25. ;;;; linking the GUILE library code into it.
  26. ;;;;
  27. ;;;; This exception does not however invalidate any other reasons why
  28. ;;;; the executable file might be covered by the GNU General Public License.
  29. ;;;;
  30. ;;;; This exception applies only to the code released by the
  31. ;;;; Free Software Foundation under the name GUILE.  If you copy
  32. ;;;; code from other Free Software Foundation releases into a copy of
  33. ;;;; GUILE, as the General Public License permits, the exception does
  34. ;;;; not apply to the code that you add in this way.  To avoid misleading
  35. ;;;; anyone as to the status of such modified files, you must delete
  36. ;;;; this exception notice from them.
  37. ;;;;
  38. ;;;; If you write modifications of your own for GUILE, it is your choice
  39. ;;;; whether to permit this exception to apply to your modifications.
  40. ;;;; If you do not wish that, delete this exception notice.
  41. ;;;;
  42.  
  43. ;;; Commentary:
  44.  
  45. ;; This module is documented in the Guile Reference Manual.
  46. ;; Briefly, these are exported:
  47. ;;  procedures: expect-select, expect-regexec
  48. ;;   variables: expect-port, expect-timeout, expect-timeout-proc,
  49. ;;              expect-eof-proc, expect-char-proc,
  50. ;;              expect-strings-compile-flags, expect-strings-exec-flags,
  51. ;;      macros: expect, expect-strings
  52.  
  53. ;;; Code:
  54.  
  55. (define-module (ice-9 expect)
  56.   :use-module (ice-9 regex)
  57.   :export-syntax (expect expect-strings)
  58.   :export (expect-port expect-timeout expect-timeout-proc
  59.        expect-eof-proc expect-char-proc expect-strings-compile-flags
  60.        expect-strings-exec-flags expect-select expect-regexec))
  61.  
  62. ;;; Expect: a macro for selecting actions based on what it reads from a port.
  63. ;;; The idea is from Don Libes' expect based on Tcl.
  64. ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
  65.  
  66.  
  67. (define expect-port #f)
  68. (define expect-timeout #f)
  69. (define expect-timeout-proc #f)
  70. (define expect-eof-proc #f)
  71. (define expect-char-proc #f)
  72.  
  73. ;;; expect: each test is a procedure which is applied to the accumulating
  74. ;;; string.
  75. (defmacro expect clauses
  76.   (let ((s (gensym))
  77.     (c (gensym))
  78.     (port (gensym))
  79.     (timeout (gensym)))
  80.     `(let ((,s "")
  81.        (,port (or expect-port (current-input-port)))
  82.        ;; when timeout occurs, in floating point seconds.
  83.        (,timeout (if expect-timeout
  84.              (let* ((secs-usecs (gettimeofday)))
  85.                (+ (car secs-usecs)
  86.                   expect-timeout
  87.                   (/ (cdr secs-usecs)
  88.                  1000000))) ; one million.
  89.              #f)))
  90.        (let next-char ()
  91.      (if (and expect-timeout
  92.           (not (expect-select ,port ,timeout)))
  93.          (if expect-timeout-proc
  94.          (expect-timeout-proc ,s)
  95.          #f)
  96.          (let ((,c (read-char ,port)))
  97.            (if expect-char-proc
  98.            (expect-char-proc ,c))
  99.            (if (not (eof-object? ,c))
  100.            (set! ,s (string-append ,s (string ,c))))
  101.            (cond
  102.         ;; this expands to clauses where the car invokes the
  103.         ;; match proc and the cdr is the return value from expect
  104.         ;; if the proc matched.
  105.         ,@(let next-expr ((tests (map car clauses))
  106.                   (exprs (map cdr clauses))
  107.                   (body '()))
  108.             (cond
  109.              ((null? tests)
  110.               (reverse body))
  111.              (else
  112.               (next-expr
  113.                (cdr tests)
  114.                (cdr exprs)
  115.                (cons
  116.             `((,(car tests) ,s (eof-object? ,c))
  117.               ,@(cond ((null? (car exprs))
  118.                    '())
  119.                   ((eq? (caar exprs) '=>)
  120.                    (if (not (= (length (car exprs))
  121.                            2))
  122.                        (scm-error 'misc-error
  123.                           "expect"
  124.                           "bad recipient: ~S"
  125.                           (list (car exprs))
  126.                           #f)
  127.                        `((apply ,(cadar exprs)
  128.                         (,(car tests) ,s ,port)))))
  129.                   (else
  130.                    (car exprs))))
  131.             body)))))
  132.         ;; if none of the clauses matched the current string.
  133.         (else (cond ((eof-object? ,c)
  134.                  (if expect-eof-proc
  135.                  (expect-eof-proc ,s)
  136.                  #f))
  137.                 (else
  138.                  (next-char)))))))))))
  139.  
  140.  
  141. (define expect-strings-compile-flags regexp/newline)
  142. (define expect-strings-exec-flags regexp/noteol)
  143.  
  144. ;;; the regexec front-end to expect:
  145. ;;; each test must evaluate to a regular expression.
  146. (defmacro expect-strings clauses
  147.   `(let ,@(let next-test ((tests (map car clauses))
  148.               (exprs (map cdr clauses))
  149.               (defs '())
  150.               (body '()))
  151.         (cond ((null? tests)
  152.            (list (reverse defs) `(expect ,@(reverse body))))
  153.           (else
  154.            (let ((rxname (gensym)))
  155.              (next-test (cdr tests)
  156.                 (cdr exprs)
  157.                 (cons `(,rxname (make-regexp
  158.                          ,(car tests)
  159.                          expect-strings-compile-flags))
  160.                       defs)
  161.                 (cons `((lambda (s eof?)
  162.                       (expect-regexec ,rxname s eof?))
  163.                     ,@(car exprs))
  164.                       body))))))))
  165.  
  166. ;;; simplified select: returns #t if input is waiting or #f if timed out or
  167. ;;; select was interrupted by a signal.
  168. ;;; timeout is an absolute time in floating point seconds.
  169. (define (expect-select port timeout)
  170.   (let* ((secs-usecs (gettimeofday))
  171.      (relative (- timeout
  172.               (car secs-usecs)
  173.               (/ (cdr secs-usecs)
  174.              1000000))))    ; one million.
  175.     (and (> relative 0)
  176.      (pair? (car (select (list port) '() '()
  177.                  relative))))))
  178.  
  179. ;;; match a string against a regexp, returning a list of strings (required
  180. ;;; by the => syntax) or #f.  called once each time a character is added
  181. ;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
  182. (define (expect-regexec rx s eof?)
  183.   ;; if expect-strings-exec-flags contains regexp/noteol,
  184.   ;; remove it for the eof test.
  185.   (let* ((flags (if (and eof?
  186.              (logand expect-strings-exec-flags regexp/noteol))
  187.             (logxor expect-strings-exec-flags regexp/noteol)
  188.             expect-strings-exec-flags))
  189.      (match (regexp-exec rx s 0 flags)))
  190.     (if match
  191.     (do ((i (- (match:count match) 1) (- i 1))
  192.          (result '() (cons (match:substring match i) result)))
  193.         ((< i 0) result))
  194.     #f)))
  195.  
  196. ;;; expect.scm ends here
  197.